;;;; Copyright 2009 Peter von Etter

;;;; This file is part of Autoproject

;;;; Autoproject is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; Autoproject is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with Autoproject.  If not, see
;;;; <http://www.gnu.org/licenses/>.

(defpackage :autoproject.pkg
  (:nicknames :pkg)
  (:use :cl)
  (:export #:alias))

(in-package :autoproject.pkg)

(defvar *last-ops* nil)
(defvar *debug* nil)

;;;; Primitives

(defun replace-package-name (package old-name new-name)
  (let* ((p (find-package package))
         (name (package-name p)))
    (if (equal (package-name p) old-name)
        ;; Real name
        (rename-package p new-name
                        (package-nicknames p))
        ;; Nick
        (rename-package p name 
                        (substitute new-name old-name 
                                    (package-nicknames p)
                                    :test 'equal)))))

(defun shadowed-package-name (name)
  (concatenate 'string name "%"))

(defun non-shadowed-package-name (shadowed-package-name)
  (subseq shadowed-package-name 0 (1- (length shadowed-package-name))))

;;;;

(defun shadow-package-name (name)
  (replace-package-name (find-package name)
                        name (shadowed-package-name name)))

(defun unshadow-package-name (unshadowed-name)
  (let ((shadowed (shadowed-package-name unshadowed-name)))
    (replace-package-name (find-package shadowed)
                          shadowed
                          unshadowed-name)))

;; Change real name
(defun rename-package-really (package new-name)
  (let ((p (find-package package)))
    (rename-package p new-name (package-nicknames p))))

(defun add-nickname (package nickname)
  (let ((p (find-package package)))
    (rename-package p (package-name p)
                    (cons nickname (package-nicknames p)))))

(defun remove-nickname (package nickname)
  (let ((p (find-package package)))
    (rename-package p (package-name p)
                    (remove (string nickname)
                            (package-nicknames p)
                            :test 'equal))))

;;;;

(defun reverse-op (operation-name &rest args)
  (ecase operation-name
    
    (rename-package-really
     (destructuring-bind (package new-name) args
       (setf new-name (string new-name))
       (list 'rename-package-really
             new-name
             (package-name package))))
              
    (add-nickname
     (destructuring-bind (package nickname) args
       (setf nickname (string nickname))
       (list 'remove-nickname
             package
             nickname)))

    (remove-nickname
     (destructuring-bind (package nickname) args
       (setf nickname (string nickname))
       (list 'add-nickname
             package
             nickname)))
    
    (replace-package-name
     (destructuring-bind (package old new) args
       (setf old (string old)
             new (string new))                         
       (if (equal package old)
           (list 'replace-package-name
                 new
                 new
                 old)
           (list 'replace-package-name
                 (package-name package)
                 new 
                 old))))
    
    (shadow-package-name 
     (destructuring-bind (name) args
       (setf name (string name))
       (list 'unshadow-package-name name)))    
    
    (unshadow-package-name 
     (destructuring-bind (name) args
       (setf name (string name))
       (list 'shadow-package-name name)))))


(defun restore-package-state ()
  (when *last-ops*
    (funcall *last-ops*)))

(defun save-package-state (ops)
  (setf *last-ops* ops))

(defun reset ()
  (restore-package-state)
  (setf *last-ops* nil))


;; Apply f to ops stack, then execute the first op, then continue
;; recursively.  Update undo after each op.

(defun apply-ops-with-undo (ops &optional (f 'identity) (undo (constantly t)))
  (if (null ops)
      undo ;; Success
      (let ((new-ops (funcall f ops)))
        (destructuring-bind ((op &rest args) &rest rest) new-ops
          (when *debug* (print (first new-ops)))
          (handler-case (apply op args)
            (error ()
              (funcall undo)
              (error "Could not execute ~S" (first new-ops))))
          (apply-ops-with-undo 
           rest f (lambda ()
                    (let ((reverse (apply 'reverse-op op args)))
                      (when *debug* (print reverse))
                      (apply (first reverse) (rest reverse))
                      (funcall undo))))))))


;; Pushes shadowing ops onto the ops stack
(defun do-shadowing-op (ops)
  (case (first (first ops))
    
    (add-nickname 
     (destructuring-bind (op package nick) (first ops)
       (declare (ignore op package))
       (if (find-package nick)
           (do-shadowing-op (cons (list 'shadow-package-name nick) ops))
           ops)))

    (shadow-package-name
     (destructuring-bind (op name) (first ops)
       (declare (ignore op))
       (let ((shadowed (shadowed-package-name name)))
         (if (find-package shadowed)
             (do-shadowing-op (cons (list 'shadow-package-name shadowed) ops))
             ops))))

    (t ops)))
             
(defun alias (&optional package-nick-alist)
  "Renames packages according to PACKAGE-NICK-ALIST.  Any existing
packages will be shadowed.  Calling this function again removes the
nicknames and restores the old packages names, then assigns the new
names, if any were given.

Example:

  (pkg:alias '((:cl-ppcre :re)
               (:com.my.really.long.domain.util :util)))

This will assign the nickname \"RE\" to :cl-ppcre and the nickname
\"UTIL\" to :my.really.long.domain.com.util.  If an existing \"UTIL\"
package exists, it will be renamed \"UTIL%\" until the next time ALIAS
is called (\"UTIL%\" becomes \"UTIL%%\" etc)."  
  (reset)
  
  ;; Stringify
  (setf package-nick-alist
        (mapcar (lambda (x)
                  (mapcar #'string x))
                package-nick-alist))
  
  (let* ((ops (mapcar (lambda (x)
                        (destructuring-bind (package nick) x
                          (list 'add-nickname package nick)))
                      package-nick-alist))
         (undo (apply-ops-with-undo ops 'do-shadowing-op)))
    
    (save-package-state undo)
    t))


(defun test-1 ()
  (flet ((describe-packages ()
           (describe (find-package "FOO"))
           (describe (find-package "BAR"))
           (describe (find-package "FOO-BAR-QWE"))
           (describe (find-package "FOO%"))
           (describe (find-package "FOO%%"))))
    
    (let ((*debug* t))
  
      (ignore-errors (delete-package "FOO"))
      (ignore-errors (delete-package "BAR"))
      (ignore-errors (delete-package "FOO-BAR-QWE"))
      (ignore-errors (delete-package "FOO%"))  
      (ignore-errors (delete-package "FOO%%"))
      
      (defpackage :foo)
      (defpackage :foo-bar-qwe)
      (defpackage :bar)
      (defpackage "FOO%")

      (rename-package "FOO" "FOO" nil)
      (rename-package "BAR" "BAR" nil)
      (rename-package "FOO-BAR-QWE" "FOO-BAR-QWE" nil)
      (rename-package "FOO%" "FOO%" nil)

      (reset)

      (format t "~%Before:~%")
      (describe-packages)
  
      (alias '((:foo :f)
               (:bar :b)
               (:foo-bar-qwe :foo)))

      (format t "~%After:~%")
      (describe-packages)
  
      (alias)
  
      (format t "~&Reset:~%")
      (describe-packages))))

(defun test-2 ()
  (defpackage :foo)
  (let ((p (find-package :foo)))
    (rename-package p "FOO%")
    (assert (eq p (find-package "FOO%")))
    (delete-package "FOO%")))

